home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / compiler / Infixres.sml < prev    next >
Encoding:
Text File  |  1997-08-18  |  22.9 KB  |  684 lines  |  [TEXT/R*ch]
  1.  
  2. open List Fnlib Mixture Const Smlexc Smlprim Globals Location;
  3. open Units Types Asynt Asyntfn Primdec Infixst Synchk;
  4.  
  5. fun lookup_iBas (iBas : InfixBasis) id =
  6.   lookupEnv iBas id
  7.   handle Subscript => NONFIXst
  8. ;
  9.  
  10. fun lookup_cBasForPat cBas (ii : IdInfo) =
  11.   let val { qualid, info } = ii
  12.       val { idLoc, ... } = info
  13.   in
  14.     findInfo conBasisOfSig cBas idLoc qualid
  15.     (* Otherwise ii is being defined it the pattern... *)
  16.     handle Subscript => { qualid=qualid, info=VARname REGULARo }
  17.   end
  18. ;
  19.  
  20. fun lookup_cBas cBas (ii : IdInfo) =
  21.   let val { qualid, info } = ii
  22.       val { idLoc, ... } = info
  23.   in
  24.     findInfo conBasisOfSig cBas idLoc qualid
  25.     handle Subscript =>
  26.       errorMsg idLoc ("Unbound value identifier: " ^ showQualId qualid)
  27.   end
  28. ;
  29.  
  30. fun asId_Exp (_, VARexp(ref (RESve ii))) =
  31.       let val { qualid, info } = ii in
  32.         if #qual qualid <> "" orelse #withOp info then NONE else SOME ii
  33.       end
  34.   | asId_Exp (_, _) = NONE
  35. ;
  36.  
  37. fun applyId_Exp (ii : IdInfo) exp =
  38.   let val { qualid, info } = ii
  39.       val { idLoc, ... } = info
  40.   in
  41.     (xLR exp, APPexp((idLoc, VARexp(ref (RESve ii))), exp))
  42.   end
  43. ;
  44.  
  45. fun applyObj_Exp exp1 exp2 = (xxLR exp1 exp2, APPexp(exp1, exp2));
  46.  
  47. val theExpStack =
  48. {
  49.   pair=pairExp, asId=asId_Exp,
  50.   applyId=applyId_Exp, applyObj=applyObj_Exp
  51. };
  52.  
  53. fun resolveInfixExp (iBas : InfixBasis) loc exps =
  54.   resolveInfix theExpStack (lookup_iBas iBas) exps
  55.   handle WrongInfix =>
  56.     errorMsg loc "Ill-formed infix expression"
  57.        | MixedAssociativity =>
  58.     errorMsg loc "Mixed left- and right-associative operators of equal precedence"
  59. ;
  60.  
  61. fun asId_Pat (_, VARpat ii) =
  62.       let val { qualid, info } = ii in
  63.         if #qual qualid <> "" orelse #withOp info then NONE else SOME ii
  64.       end
  65.   | asId_Pat (_, _) = NONE
  66. ;
  67.  
  68. fun applyId_Pat ii pat = (xLR pat, CONSpat(ii, pat ));
  69.  
  70. fun applyObj_Pat pat1 pat2 =
  71.   case pat1 of
  72.       (_, VARpat ii) => (xxLR pat1 pat2, CONSpat(ii, pat2))
  73.     | (loc, _) => errorMsg loc "Non-identifier applied to a pattern"
  74. ;
  75.  
  76. val thePatStack =
  77.   {
  78.     pair=pairPat, asId=asId_Pat,
  79.     applyId=applyId_Pat, applyObj=applyObj_Pat
  80.   }
  81. ;
  82.  
  83. fun resolveInfixPat iBas loc pats =
  84.   resolveInfix thePatStack (lookup_iBas iBas) pats
  85.   handle WrongInfix =>
  86.     errorMsg loc "Ill-formed infix pattern"
  87.        | MixedAssociativity =>
  88.     errorMsg loc "Mixed left- and right-associative operators of equal precedence"
  89. ;
  90.  
  91. fun addCon cs (cBas : ConBasis) =
  92.   let val {qualid, info} = cs in
  93.     bindInEnv cBas (#id qualid) { qualid=qualid, info=CONname info }
  94.   end
  95. ;
  96.  
  97. fun addExCon (id, cs) (cBas : ConBasis) =
  98.   let val {qualid, info} = cs in
  99.     bindInEnv cBas id { qualid= qualid, info=EXNname info }
  100.   end
  101. ;
  102.  
  103. fun addVar id (cBas : ConBasis) =
  104.   let val q = mkGlobalName id
  105.       val vi = { qualid=q, info=REGULARo }
  106.   in bindInEnv cBas id { qualid=q, info=VARname REGULARo } end
  107. ;
  108.  
  109. fun addPrimVal (id, cs) (cBas : ConBasis) =
  110.   bindInEnv cBas id cs
  111. ;
  112.  
  113. fun addPatVars pat cBas = foldL addVar cBas (domPat pat);
  114.  
  115. fun errorVarAsCon (ii : IdInfo) =
  116.   errorMsg (#idLoc (#info ii)) "A constructor name expected"
  117. ;
  118.  
  119. fun errorPrimAsCon (ii : IdInfo) =
  120.   errorMsg (#idLoc (#info ii)) "A constructor name expected"
  121. ;
  122.  
  123. fun resolvePatCon (cBas : ConBasis) (pat as (loc, pat')) =
  124.   case pat' of
  125.       SCONpat _ => pat
  126.     | VARpat ii =>
  127.         let val cs = lookup_cBasForPat cBas ii
  128.             val {qualid, info} = ii
  129.         in
  130.           case #info cs of
  131.             VARname _ =>
  132.               (if #qual qualid <> "" then
  133.                  errorMsg (#idLoc info)
  134.                    "Variable names in patterns cannot be qualified"
  135.                else ();
  136.                pat)
  137.           | PRIMname _ =>
  138.               (if #qual qualid <> "" then
  139.                  errorMsg (#idLoc info)
  140.                    "Variable names in patterns cannot be qualified"
  141.                else ();
  142.                pat)
  143.           | CONname ci =>
  144.               (if #conArity(!ci) <> 0 then
  145.                  errorMsg (#idLoc info)
  146.                    "Unary constructor in the pattern needs an argument"
  147.                else ();
  148.                #idKind info := { qualid= #qualid cs, info=CONik ci };
  149.                (loc, NILpat ii))
  150.           | EXNname ei =>
  151.               (if #exconArity(!ei) <> 0 then
  152.                  errorMsg (#idLoc info)
  153.                    "Unary exception constructor in the pattern needs an argument"
  154.                else ();
  155.                #idKind info := { qualid= #qualid cs, info=EXCONik ei };
  156.                (loc, EXNILpat ii))
  157.           | REFname   =>
  158.               errorMsg (#idLoc info) "`ref` is used as a variable"
  159.         end
  160.     | WILDCARDpat => pat
  161.     | NILpat ii => fatalError "resolvePatCon"
  162.     | CONSpat(ii, p) =>
  163.         let val cs = lookup_cBasForPat cBas ii
  164.             val {qualid, info} = ii
  165.         in
  166.           case #info cs of
  167.             VARname _ => errorVarAsCon ii
  168.           | PRIMname _ => errorPrimAsCon ii
  169.           | CONname ci =>
  170.               (if #conArity(!ci) = 0 then
  171.                  errorMsg (#idLoc info)
  172.                    "Nullary constructor in a pattern cannot be applied"
  173.                else ();
  174.                #idKind info := { qualid= #qualid cs, info=CONik ci };
  175.                (loc, CONSpat(ii, resolvePatCon cBas p)))
  176.           | EXNname ei =>
  177.               (#idKind info := { qualid= #qualid cs, info=EXCONik ei };
  178.                (loc, EXCONSpat(ii, resolvePatCon cBas p)))
  179.           | REFname   => (loc, REFpat (resolvePatCon cBas p))
  180.         end
  181.     | EXNILpat _ => fatalError "resolvePatCon"
  182.     | EXCONSpat _ => fatalError "resolvePatCon"
  183.     | EXNAMEpat _ => fatalError "resolvePatCon"
  184.     | REFpat _ => fatalError "resolvePatCon"
  185.     | RECpat(ref (RECrp(fs, dots))) =>
  186.         (loc, RECpat(ref (RECrp(map_fields (resolvePatCon cBas) fs, dots))))
  187.     | RECpat(ref (TUPLErp _)) => fatalError "resolvePatCon"
  188.     | VECpat ps =>
  189.         (loc, VECpat (map (resolvePatCon cBas) ps))
  190.     | PARpat p =>
  191.         (loc, PARpat (resolvePatCon cBas p))
  192.     | INFIXpat _ => fatalError "resolvePatCon"
  193.     | TYPEDpat(p,t) =>
  194.         (loc, TYPEDpat(resolvePatCon cBas p, t))
  195.     | LAYEREDpat(pat1, pat2) =>
  196.         (loc, LAYEREDpat(resolvePatCon cBas pat1, resolvePatCon cBas pat2))
  197. ;
  198.  
  199. fun resolvePatOp (iBas : InfixBasis) (pat as (loc, pat')) =
  200.   case pat' of
  201.       SCONpat _ => pat
  202.     | VARpat _ => pat
  203.     | WILDCARDpat => pat
  204.     | NILpat _ => fatalError "resolvePatOp"
  205.     | CONSpat(ii, p) => (loc, CONSpat(ii, resolvePatOp iBas p))
  206.     | EXNILpat _ => fatalError "resolvePatOp"
  207.     | EXCONSpat _ => fatalError "resolvePatOp"
  208.     | EXNAMEpat _ => fatalError "resolvePatOp"
  209.     | REFpat _ => fatalError "resolvePatOp"
  210.     | RECpat(ref (RECrp(fs, dots))) =>
  211.         (loc, RECpat(ref (RECrp(map_fields (resolvePatOp iBas) fs, dots))))
  212.     | RECpat(ref (TUPLErp _)) => fatalError "resolvePatOp"
  213.     | VECpat ps => (loc, VECpat (map (resolvePatOp iBas) ps))
  214.     | PARpat p => (loc, PARpat (resolvePatOp iBas p))
  215.     | INFIXpat ps =>
  216.         resolveInfixPat iBas loc (map (resolvePatOp iBas) ps)
  217.     | TYPEDpat(p,t) =>
  218.         (loc, TYPEDpat(resolvePatOp iBas p, t))
  219.     | LAYEREDpat(pat1, pat2) =>
  220.         let val pat1' = resolvePatOp iBas pat1
  221.             val pat2' = resolvePatOp iBas pat2
  222.         in
  223.           (loc, LAYEREDpat(pat1', pat2'))
  224.         end
  225. ;
  226.  
  227. fun isInfix iBas id =
  228.   case lookup_iBas iBas id of
  229.     INFIXst _ => true
  230.   | INFIXRst _ => true
  231.   | NONFIXst => false
  232. ;
  233.  
  234. fun patOfIdent (ii : IdInfo) =
  235.   (#idLoc (#info ii), VARpat ii)
  236. ;
  237.  
  238. fun checkNoInfixes iBas (loc, pat') =
  239.   case pat' of
  240.     VARpat{qualid={qual="", id=id}, info={withOp=false, ...}} =>
  241.       if isInfix iBas id then
  242.         errorMsg loc "Ill-placed infix in a fun clause"
  243.       else ()
  244.   | _ => ()
  245. ;
  246.  
  247. fun mergeFCIds [] = fatalError "mergeFCIds"
  248.   | mergeFCIds [(ii, cl)] = (ii, [cl])
  249.   | mergeFCIds ((ii, cl) :: rest) =
  250.       let val (ii', cls) = mergeFCIds rest in
  251.         if #id(#qualid ii) <> #id(#qualid ii') then
  252.           errorMsg (#idLoc (#info ii')) "Different function names in clauses"
  253.         else ();
  254.         (ii : IdInfo, cl::cls)
  255.       end
  256. ;
  257.  
  258. datatype 'a Category = INFIXED of 'a | OTHER;
  259.  
  260. fun categorize iBas (_, pat') =
  261.   case pat' of
  262.     VARpat {info={withOp=true, ...}, ...} => OTHER
  263.   | VARpat (ii as {qualid={qual="", id=id}, info={withOp=false, ...}}) =>
  264.       if (isInfix iBas id) then (INFIXED ii) else OTHER
  265.   | _ => OTHER
  266. ;
  267.  
  268. fun resolveFClauseArgs iBas (pats : Pat list) =
  269.   case map (categorize iBas) pats of
  270.     [OTHER, INFIXED ii, OTHER] =>
  271.       (* SUCCESS: case (4) *)
  272.       (case pats of
  273.            [ap1,_,ap2] => (ii, [pairPat ap1 ap2])
  274.          | _ => fatalError "resolveFClauseArgs")
  275.   | OTHER :: _ =>
  276.       (* Try for cases (1)/(2)/(3) *)
  277.       (case pats of
  278.            (_, PARpat(_, INFIXpat [ap1,ap2,ap3])) :: rest =>
  279.              (* Try for case (3) *)
  280.              (case categorize iBas ap2 of
  281.                   INFIXED ii =>
  282.                     (* SUCCESS: case (3) *)
  283.                     (ii, pairPat ap1 ap3 :: rest)
  284.                 | OTHER =>
  285.                     (* `fun (<ap1> <junk> <ap2>)' *)
  286.                     errorMsg (xLR ap2)
  287.                       "Expecting infixed identifier")
  288.          | fst :: snd :: rest =>
  289.              (* Try for cases (1)/(2)... *)
  290.              (case fst of
  291.                  (_, VARpat ii) =>
  292.                    (* ii can't be an infix, because it matches OTHER *)
  293.                    (ii, snd :: rest)
  294.                | (_, _) =>
  295.                    (* `fun <junk> <junk> ...' *)
  296.                    errorMsg (xxLR fst snd) "Ill-formed clause start")
  297.          | _ =>
  298.              (* `fun <ap> = ...' *)
  299.              errorMsg (xLR (hd pats))
  300.                "Ill-formed left hand side of a clause")
  301.   | _ =>
  302.      (* `fun +' or something *)
  303.      errorMsg (xLR (hd pats))
  304.        "Expecting function name or infix pattern"
  305. ;
  306.  
  307. fun resolveFClause iBas (FClause(pats, exp)) =
  308.   let val (ii, args) = resolveFClauseArgs iBas pats
  309.       val () = app (checkNoInfixes iBas) args
  310.       val args' = map (resolvePatOp iBas) args
  311.       val exp' = resolveExpOp iBas exp
  312.   in (ii, MRule(args', exp')) end
  313.  
  314. and resolveFClauseList iBas fclauses =
  315.   mergeFCIds (map (resolveFClause iBas) fclauses)
  316.  
  317. and resolveFValBind iBas (loc, fclauses) =
  318.   let val (ii, (mrules : Match)) =
  319.               resolveFClauseList iBas fclauses
  320.       val numArgs = curriedness mrules
  321.   in
  322.     app (fn MRule(pats,_) =>
  323.            if numArgs <> List.length pats then
  324.              errorMsg loc "Mismatch in the number of curried arguments"
  325.            else ())
  326.         mrules;
  327.     ValBind(patOfIdent ii, (loc, FNexp mrules))
  328.   end
  329.  
  330. and resolveExpOp iBas (exp as (loc, exp')) =
  331.   case exp' of
  332.     SCONexp _ => exp
  333.   | VARexp _ => exp
  334.   | FNexp mrules =>
  335.       (loc, FNexp (map (resolveMRuleOp iBas) mrules))
  336.   | APPexp(e1, e2) =>
  337.       (loc, APPexp(resolveExpOp iBas e1, resolveExpOp iBas e2))
  338.   | LETexp(dec, body) =>
  339.       let val (iBas', dec') = resolveDecOp iBas dec in
  340.         (loc, LETexp(dec', resolveExpOp (plusEnv iBas iBas') body))
  341.       end
  342.   | RECexp(ref (RECre fs)) =>
  343.       (loc, RECexp(ref (RECre(map_fields (resolveExpOp iBas) fs))))
  344.   | RECexp(ref (TUPLEre _)) =>
  345.       fatalError "resolveExpOp"
  346.   | VECexp es =>
  347.       (loc, VECexp (map (resolveExpOp iBas) es))
  348.   | PARexp e =>
  349.       (loc, PARexp (resolveExpOp iBas e))
  350.   | INFIXexp es  =>
  351.       resolveInfixExp iBas loc (map (resolveExpOp iBas) es)
  352.   | TYPEDexp(e, ty) =>
  353.       (loc, TYPEDexp(resolveExpOp iBas e, ty))
  354.   | ANDALSOexp(e1, e2) =>
  355.       (loc, ANDALSOexp(resolveExpOp iBas e1, resolveExpOp iBas e2))
  356.   | ORELSEexp(e1, e2) =>
  357.       (loc, ORELSEexp(resolveExpOp iBas e1, resolveExpOp iBas e2))
  358.   | HANDLEexp(e, mrules) =>
  359.       (loc, HANDLEexp(resolveExpOp iBas e, map (resolveMRuleOp iBas) mrules))
  360.   | RAISEexp e =>
  361.       (loc, RAISEexp (resolveExpOp iBas e))
  362.   | IFexp(e0, e1, e2) =>
  363.       (loc, IFexp(resolveExpOp iBas e0, resolveExpOp iBas e1,
  364.                   resolveExpOp iBas e2))
  365.   | WHILEexp(e1, e2) =>
  366.       (loc, WHILEexp(resolveExpOp iBas e1, resolveExpOp iBas e2))
  367.   | SEQexp(e1,e2) =>
  368.       (loc, SEQexp(resolveExpOp iBas e1, resolveExpOp iBas e2))
  369.  
  370. and resolveMRuleOp iBas (MRule(pats,exp)) =
  371.   MRule(map (resolvePatOp iBas) pats, resolveExpOp iBas exp)
  372.  
  373. and resolveDecOp (iBas : InfixBasis) (dec as (loc, dec')) =
  374.   case dec' of
  375.     VALdec (tvs, (pvbs, rvbs)) =>
  376.       (NILenv, (loc, VALdec (tvs, (map (resolveValBindOp iBas) pvbs,
  377.                    map (resolveValBindOp iBas) rvbs))))
  378.   | PRIM_VALdec _ => (NILenv, dec)
  379.   | FUNdec (tvs, fvbs) =>
  380.       (NILenv, (loc, VALdec (tvs, ([], map (resolveFValBind iBas) fvbs))))
  381.   | TYPEdec _ => (NILenv, dec)
  382.   | PRIM_TYPEdec _ => (NILenv, dec)
  383.   | DATATYPEdec _ => (NILenv, dec)
  384.   | ABSTYPEdec(dbs, tbs_opt, dec2) =>
  385.       let val (iBas'',  dec'')  = resolveDecOp iBas dec2 in
  386.         (iBas'', (loc, ABSTYPEdec(dbs, tbs_opt, dec'')))
  387.       end
  388.   | EXCEPTIONdec ebs => (NILenv, dec)
  389.   | LOCALdec(dec1, dec2) =>
  390.       let val (iBas',  dec')  = resolveDecOp iBas dec1
  391.           val (iBas'', dec'') = resolveDecOp (plusEnv iBas iBas') dec2 
  392.       in (iBas'', (loc, LOCALdec(dec',dec''))) end
  393.   | OPENdec ids => (NILenv, dec)
  394.   | EMPTYdec => (NILenv,dec)
  395.   | SEQdec(dec1, dec2) =>
  396.       let val (iBas',  dec')  = resolveDecOp iBas dec1
  397.           val (iBas'', dec'') = resolveDecOp (plusEnv iBas iBas') dec2 
  398.       in (plusEnv iBas' iBas'', (loc, SEQdec(dec',dec''))) end
  399.   | FIXITYdec(status, ids) =>
  400.       (foldL (fn id => fn env => bindInEnv env id status) NILenv ids, dec)
  401.  
  402. and resolveValBindOp iBas (ValBind(pat, exp)) =
  403.   ValBind(resolvePatOp iBas pat, resolveExpOp iBas exp)
  404. ;
  405.  
  406. val piRef = mkPrimInfo 1 MLPref;
  407.  
  408. fun mkPrimStatus arity name =
  409.   PRIMname(mkPrimInfo arity (findPrimitive arity name))
  410. ;
  411.  
  412. fun resolveExpCon cBas (exp as (loc, exp')) =
  413.   case exp' of
  414.     SCONexp _ => exp
  415.   | VARexp(ref (RESve ii)) =>
  416.       let val {qualid, info} = ii
  417.           val {idKind, ... } = info
  418.           val cs = lookup_cBas cBas ii 
  419.           val {qualid=cs_qualid, ...} = cs
  420.       in
  421.         case #info cs of
  422.           VARname REGULARo =>
  423.             (idKind := { qualid=cs_qualid, info=VARik }; exp)
  424.         | VARname ovltype =>
  425.             (loc, VARexp(ref (OVLve (ii, ovltype, newUnknown()))))
  426.         | PRIMname pi =>
  427.             (idKind := { qualid=cs_qualid, info=PRIMik pi }; exp)
  428.         | CONname ci =>
  429.             (idKind := { qualid=cs_qualid, info=CONik ci }; exp)
  430.         | EXNname ei =>
  431.             (idKind := { qualid=cs_qualid, info=EXCONik ei }; exp)
  432.         | REFname   =>
  433.             (idKind := { qualid=cs_qualid, info=PRIMik piRef }; exp)
  434.       end
  435.   | VARexp(ref (OVLve _)) => fatalError "resolveExpCon"
  436.   | FNexp mrules =>
  437.       (loc, FNexp (map (resolveMRuleCon cBas) mrules))
  438.   | APPexp(e1, e2) =>
  439.       (loc, APPexp(resolveExpCon cBas e1, resolveExpCon cBas e2))
  440.   | LETexp(dec, body) =>
  441.       let val (cBas', dec') = resolveDecCon cBas false dec
  442.       in (loc, LETexp(dec', resolveExpCon (plusEnv cBas cBas') body)) end
  443.   | RECexp(ref (RECre fs)) =>
  444.       (loc, RECexp(ref (RECre (map_fields (resolveExpCon cBas) fs))))
  445.   | RECexp(ref (TUPLEre _)) => fatalError "resolveExpCon"
  446.   | VECexp es =>
  447.       (loc, VECexp (map (resolveExpCon cBas) es))
  448.   | PARexp e =>
  449.       (loc, PARexp (resolveExpCon cBas e))
  450.   | INFIXexp es  => fatalError "resolveExpCon"
  451.   | TYPEDexp(e,ty) =>
  452.       (loc, TYPEDexp(resolveExpCon cBas e, ty))
  453.   | ANDALSOexp(e1, e2) =>
  454.       (loc, ANDALSOexp(resolveExpCon cBas e1, resolveExpCon cBas e2))
  455.   | ORELSEexp(e1, e2) =>
  456.       (loc, ORELSEexp(resolveExpCon cBas e1, resolveExpCon cBas e2))
  457.   | HANDLEexp(e, mrules) =>
  458.       (loc, HANDLEexp(resolveExpCon cBas e,
  459.                       map (resolveMRuleCon cBas) mrules))
  460.   | RAISEexp e =>
  461.       (loc, RAISEexp(resolveExpCon cBas e))
  462.   | IFexp(e0, e1, e2) =>
  463.       (loc, IFexp(resolveExpCon cBas e0, resolveExpCon cBas e1,
  464.                   resolveExpCon cBas e2))
  465.   | WHILEexp(e1, e2) =>
  466.       (loc, WHILEexp(resolveExpCon cBas e1, resolveExpCon cBas e2))
  467.   | SEQexp(e1,e2) =>
  468.       (loc, SEQexp(resolveExpCon cBas e1, resolveExpCon cBas e2))
  469.  
  470. and resolveMRuleCon cBas (MRule(pats, exp)) =
  471.   let val pats' = map (resolvePatCon cBas) pats
  472.       val cBas' = foldL addPatVars cBas pats' 
  473.   in MRule(pats', resolveExpCon cBas' exp) end
  474.  
  475. and resolveDecCon cBas onTop (dec as (loc, dec')) =
  476.   case dec' of
  477.     VALdec (tvs, (pvbs, rvbs)) =>
  478.       let val (cBas', pvbs') = resolveValBindCon cBas pvbs
  479.           val (cBas'', rvbs') = resolveRecValBindCon cBas rvbs
  480.       in (plusEnv cBas' cBas'', (loc, VALdec (tvs, (pvbs', rvbs')))) end
  481.   | PRIM_VALdec pbs =>
  482.       (foldL addPrimVal NILenv (collectPrim pbs), dec)
  483.   | FUNdec _ =>  fatalError "resolveDecCon"
  484.   | TYPEdec _ => (NILenv, dec)
  485.   | PRIM_TYPEdec _ => (NILenv, dec)
  486.   | DATATYPEdec(dbs, _) =>
  487.       (foldL addCon NILenv (collectCon dbs), dec)
  488.   | ABSTYPEdec(dbs, tbs_opt, dec2) =>
  489.       let val cBas' = foldL addCon NILenv (collectCon dbs)
  490.           val (cBas'', dec'') = resolveDecCon (plusEnv cBas cBas') onTop dec2 
  491.       in (cBas'', (loc, ABSTYPEdec(dbs, tbs_opt, dec''))) end
  492.   | EXCEPTIONdec ebs =>
  493.       (foldL addExCon NILenv (collectExCon cBas onTop ebs), dec)
  494.   | LOCALdec(dec1, dec2) =>
  495.       let val (cBas', dec')   = resolveDecCon cBas onTop dec1
  496.           val (cBas'', dec'') = resolveDecCon (plusEnv cBas cBas') onTop dec2
  497.       in (cBas'', (loc, LOCALdec(dec',dec''))) end
  498.   | OPENdec ids =>
  499.       let val cBas' =
  500.         foldL (fn id => fn acc =>
  501.                  bindTopInEnv acc (#uConBasis (findAndMentionSig loc id)))
  502.               NILenv ids
  503.       in (cBas', dec) end
  504.   | EMPTYdec => (NILenv, dec)
  505.   | SEQdec(dec1, dec2) =>
  506.       let val (cBas', dec')   = resolveDecCon cBas onTop dec1
  507.           val (cBas'', dec'') = resolveDecCon (plusEnv cBas cBas') onTop dec2
  508.       in (plusEnv cBas' cBas'', (loc, SEQdec(dec',dec''))) end
  509.   | FIXITYdec _ => (NILenv, dec)
  510.  
  511. and resolveValBindCon cBas vbs =
  512.   let val pats = map (fn ValBind(p,_) => resolvePatCon cBas p) vbs
  513.       val cBas' = foldL addPatVars NILenv pats
  514.       val exps = map (fn ValBind(_,e) => resolveExpCon cBas e) vbs
  515.       val vbs' = map2 (fn p => fn e => ValBind(p,e)) pats exps 
  516.   in (mkHashEnv (length pats) cBas', vbs') end
  517.  
  518. and resolveRecValBindCon cBas vbs =
  519.   let val pats = map (fn ValBind(p,_) => resolvePatCon cBas p) vbs
  520.       val cBas' = foldL addPatVars NILenv pats
  521.       val cBas'' = mkHashEnv (length pats) cBas'
  522.       val rec_cBas = plusEnv cBas cBas''
  523.       val exps = map (fn ValBind(_,e) => resolveExpCon rec_cBas e) vbs
  524.       val vbs' = map2 (fn p => fn e => ValBind(p,e)) pats exps 
  525.   in (cBas'', vbs') end
  526.  
  527. and collectPrimInPB (ii, ty, arity, name) =
  528.   let val {qualid, ...} = ii
  529.       val {id, ...} = qualid
  530.       val q = mkGlobalName id 
  531.   in (id, { qualid=q, info=(mkPrimStatus arity name) }) end
  532.  
  533. and collectPrim pbs = map collectPrimInPB pbs
  534.  
  535. and collectConInCB (ConBind(ii, ty_opt)) =
  536.   let val {qualid, info} = ii
  537.       val ci = mkConInfo()
  538.       val q = mkGlobalName (#id qualid) 
  539.   in
  540.     #idKind info := { qualid=q, info=CONik ci };
  541.     (* If conArity = 1, it may be updated later for greedy constructors. *)
  542.     (case ty_opt of
  543.          SOME _ => setConArity ci 1
  544.        | NONE   => setConArity ci 0);
  545.     { qualid=q, info=ci }
  546.   end
  547.  
  548. and collectCon dbs =
  549.   concat( map (fn (_,_,cbs) => map collectConInCB cbs) dbs )
  550.  
  551. and collectExCon cBas onTop ebs =
  552.   map (collectExConInEB cBas onTop) ebs
  553.  
  554. and collectExConInEB cBas onTop = fn
  555.     EXDECexbind(ii, ty_opt) =>
  556.       let val {qualid, info} = ii
  557.           val {id, ...} = qualid
  558.           val ei = mkExConInfo()
  559.           val q = mkGlobalName id 
  560.       in
  561.         #idKind info := { qualid=q, info=EXCONik ei };
  562.         (case ty_opt of
  563.              SOME _ => setExConArity ei 1
  564.            | NONE   => setExConArity ei 0);
  565.         if onTop then
  566.           setExConTag ei (SOME (q, newExcStamp()))
  567.         else ();
  568.         (id, { qualid=q, info=ei })
  569.       end
  570.   | EXEQUALexbind(ii, ii') =>
  571.       let val {qualid, info} = ii
  572.           val {id, ...} = qualid
  573.           val {qualid=qualid', info=info'} = ii'
  574.           val {idLoc=loc', ...} = info'
  575.           val cs = lookup_cBas cBas ii' 
  576.       in
  577.         case #info cs of
  578.             VARname _ => errorMsg loc'
  579.               ("Variable "^showQualId qualid' ^" is used as an exception name")
  580.           | PRIMname _ => errorMsg loc'
  581.               ("Primitive "^showQualId qualid' ^" is used as an exception name")
  582.           | CONname _ => errorMsg loc'
  583.               ("Constructor "^showQualId qualid' ^" is used as an exception name")
  584.           | EXNname ei' =>
  585.               let val q = mkGlobalName id in
  586.                 #idKind info' := { qualid= #qualid cs, info=EXCONik ei' };
  587.                 #idKind info  := { qualid=q, info=EXCONik ei' };
  588.                 (id, { qualid=q, info=ei' })
  589.               end
  590.           | REFname   => errorMsg loc'
  591.               "`ref' is used as an exception name"
  592.       end
  593. ;
  594.  
  595. (* --- resolveToplevelDec --- *)
  596.  
  597. fun resolveToplevelDec dec =
  598.   let val (iBas', dec')  = resolveDecOp (mkGlobalInfixBasis()) dec
  599.       val (cBas', dec'') = resolveDecCon (mkGlobalConBasis()) true dec'
  600.   in
  601.     checkDec true dec'';
  602.     (iBas', cBas', dec'')
  603.   end
  604. ;
  605.  
  606. (* --- Signatures --- *)
  607.  
  608. fun collectExConInED cBas (ii, ty_opt) =
  609.   let val {qualid, info} = ii : IdInfo
  610.       val {id, ...} = qualid
  611.       val ei = mkExConInfo()
  612.       val q = mkGlobalName id 
  613.   in
  614.     #idKind info := { qualid=q, info=EXCONik ei };
  615.     (case ty_opt of
  616.          SOME _ => setExConArity ei 1
  617.        | NONE   => setExConArity ei 0);
  618.     setExConTag ei (SOME (q, 0));
  619.     (id, { qualid=q, info=ei })
  620.   end
  621. ;
  622.  
  623. fun collectExConInEDs cBas eds =
  624.   map (collectExConInED cBas) eds
  625. ;
  626.  
  627. fun resolveSpecOp (iBas : InfixBasis) (spec as (loc, spec')) =
  628.   case spec' of
  629.     VALspec _ => NILenv
  630.   | PRIM_VALspec _ => NILenv
  631.   | TYPEDESCspec _ => NILenv
  632.   | TYPEspec _ => NILenv
  633.   | DATATYPEspec _ => NILenv
  634.   | EXCEPTIONspec eds => NILenv
  635.   | LOCALspec(spec1, spec2) =>
  636.       let val iBas'  = resolveSpecOp iBas spec1
  637.           val iBas'' = resolveSpecOp (plusEnv iBas iBas') spec2 
  638.       in iBas'' end
  639.   | OPENspec ids => NILenv
  640.   | EMPTYspec => NILenv
  641.   | SEQspec(spec1, spec2) =>
  642.       let val iBas' = resolveSpecOp iBas spec1
  643.           val iBas'' = resolveSpecOp (plusEnv iBas iBas') spec2 
  644.       in plusEnv iBas' iBas'' end
  645. ;
  646.  
  647. fun collectVar vds = map (fn (ii : IdInfo, _) => #id(#qualid ii)) vds;
  648.  
  649. fun resolveSpecCon cBas (spec as (loc, spec')) =
  650.   case spec' of
  651.     VALspec vds =>
  652.       foldL addVar NILenv (collectVar vds)
  653.   | PRIM_VALspec pbs =>
  654.       foldL addPrimVal NILenv (collectPrim pbs)
  655.   | TYPEDESCspec _ => NILenv
  656.   | TYPEspec _ => NILenv
  657.   | DATATYPEspec(dbs, _) =>
  658.       foldL addCon NILenv (collectCon dbs)
  659.   | EXCEPTIONspec eds =>
  660.       foldL addExCon NILenv (collectExConInEDs cBas eds)
  661.   | LOCALspec(spec1, spec2) =>
  662.       let val cBas'  = resolveSpecCon cBas spec1
  663.           val cBas'' = resolveSpecCon (plusEnv cBas cBas') spec2 
  664.       in cBas'' end
  665.   | OPENspec ids =>
  666.       foldL (fn id => fn acc =>
  667.                bindTopInEnv acc (#uConBasis (findAndMentionSig loc id)))
  668.             NILenv ids
  669.   | EMPTYspec => NILenv
  670.   | SEQspec(spec1, spec2) =>
  671.       let val cBas'  = resolveSpecCon cBas spec1
  672.           val cBas'' = resolveSpecCon (plusEnv cBas cBas') spec2 
  673.       in plusEnv cBas' cBas'' end
  674. ;
  675.  
  676. (* --- resolveToplevelSpec --- *)
  677.  
  678. fun resolveToplevelSpec spec =
  679.   let val () = checkSpec true spec
  680.       val iBas' = resolveSpecOp (mkGlobalInfixBasis()) spec
  681.       val cBas' = resolveSpecCon (mkGlobalConBasis()) spec 
  682.   in (iBas', cBas') end
  683. ;
  684.